home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / musictex / older-versions / musictex.502 / SORTINDX.FOR < prev   
Text File  |  1993-06-06  |  21KB  |  643 lines
  1.       PROGRAM SORTINDX
  2.       IMPLICIT INTEGER(A-Z)
  3.       PARAMETER(LLTH=255,MTAB=700,TLTH=100)
  4.       PARAMETER(ZLTH=128000/MTAB)
  5.       CHARACTER*(LLTH) LIGNE,CLIGNE
  6.       CHARACTER*(TLTH) FTABL(MTAB)
  7.       CHARACTER*(ZLTH) TABLE(MTAB)
  8.       CHARACTER*(LLTH) TEXTI,TEXTJ
  9.       CHARACTER*1 MAJUSC(0:255)
  10.       INTEGER LETTER(0:255),DIGIT(0:255)
  11.       INTEGER ORDNO(MTAB)
  12.       CHARACTER*64 INPUT,OUTPUT,OPTION
  13.       CHARACTER*(*) INDEXENTRY
  14.       LOGICAL REPACK,UPCASE_COMP
  15.       PARAMETER (INDEXENTRY='\indexentry')
  16.       CHARACTER*64 END_SKIP 
  17. C
  18.       LENTRY=LEN(INDEXENTRY)
  19.       LANGUAGE=0 
  20.       REPACK=.FALSE.
  21.       UPCASE_COMP=.TRUE.
  22. C 0=anglais, 1=francais, 2=allemand 3=espagnol  4=italien
  23. C unix:      NARGS=IARGC()
  24. C DOS 5.0:   NUMARGS=NARGS()-1
  25.       NUMARGS=NARGS()-1
  26.       INPUT=' '
  27.       OUTPUT=' '
  28.       END_SKIP=' '
  29.       DO 15 J=1,NUMARGS
  30.         CALL GETARG(J,OPTION,KSTAT)
  31.         IF(OPTION(1:1) .NE. '-') THEN 
  32.           IF(INPUT .EQ. ' ') THEN
  33.             INPUT=OPTION
  34.           ELSE IF(OUTPUT .EQ. ' ') THEN
  35.             OUTPUT=OPTION
  36.           ELSE
  37.             PRINT *,'Exceeding parameter:',OPTION(:TRIMLN(OPTION))
  38.           END IF
  39.         ELSE IF(OPTION .EQ. '-e') THEN
  40.           LANGUAGE=0
  41.         ELSE IF(OPTION .EQ. '-f') THEN
  42.           LANGUAGE=1
  43.         ELSE IF(OPTION .EQ. '-g') THEN
  44.           LANGUAGE=2
  45.         ELSE IF(OPTION .EQ. '-s') THEN
  46.           LANGUAGE=3
  47.         ELSE IF(OPTION .EQ. '-i') THEN
  48.           LANGUAGE=4
  49.         ELSE IF(OPTION .EQ. '-A') THEN
  50.           REPACK=.TRUE.
  51.         ELSE IF(OPTION .EQ. '-C') THEN
  52.           UPCASE_COMP=.FALSE.
  53.         ELSE IF(OPTION(1:2) .EQ. '-X' .AND. OPTION(3:).NE.' ')THEN
  54.           END_SKIP=OPTION(3:)
  55.         ELSE IF(OPTION .EQ. '-h') THEN 
  56.           PRINT *,'Sortindx, version 1.2 - D. Taupin'
  57.           PRINT *,' '
  58.           PRINT *,'  SORTINDX [options] <input-file> <output-file> ',
  59.      $      '[options]'
  60.           PRINT *,' ' 
  61.           PRINT *,'Options: -e : english alphabetical order' 
  62.           PRINT *,'Options: -f : french alphabetical order' 
  63.           PRINT *,'Options: -g : german alphabetical order' 
  64.           PRINT *,'Options: -h : this help' 
  65.           PRINT *,'Options: -i : italian alphabetical order' 
  66.           PRINT *,'Options: -s : spanish alphabetical order ~n/ch/ll' 
  67.           PRINT *,'Options: -A : repack spaces and {\accent x x}' 
  68.           PRINT *,'Options: -C : case dependent sorting (A>z)' 
  69.           PRINT *,'Options: -X<string> : eliminate index entry text',
  70.      $     ' until <string> (included)'
  71.           PRINT *,'                      in sorted file' 
  72.           PRINT *,'------------- RETURN KEY TO RESUME ------------'
  73.           READ '(A)',OPTION
  74.         ELSE
  75.           PRINT *,'Illegal option:',OPTION(:TRIMLN(OPTION))
  76.           STOP
  77.         END IF
  78. 15    CONTINUE
  79. C
  80.       PRINT *,'input :',INPUT
  81.       PRINT *,'output:',OUTPUT
  82.       PRINT *,'language=',LANGUAGE
  83. C
  84.       DO 40 I=0,255
  85.         LETTER(I)=0
  86.         MAJUSC(I)=CHAR(I)
  87.         DIGIT(I)=-1
  88. 40    CONTINUE
  89.       MAJMIN=ICHAR('A')-ICHAR('a')
  90.       J=0
  91.       DO 41 I=ICHAR('A'),ICHAR('I')
  92.       J=J+1
  93.       LETTER(I)=J
  94.       MAJUSC(I-MAJMIN)=CHAR(I)
  95. 41    CONTINUE
  96.       DO 42 I=ICHAR('J'),ICHAR('R')
  97.       J=J+1
  98.       LETTER(I)=J
  99.       MAJUSC(I-MAJMIN)=CHAR(I)
  100. 42    CONTINUE
  101.       DO 43 I=ICHAR('S'),ICHAR('Z')
  102.       J=J+1
  103.       LETTER(I)=J
  104.       MAJUSC(I-MAJMIN)=CHAR(I)
  105. 43    CONTINUE
  106.       J=0
  107.       DO 44 I=ICHAR('0'),ICHAR('9')
  108.       DIGIT(I)=J
  109.       J=J+1
  110. 44    CONTINUE
  111.       OPEN(8,FILE=INPUT,IOSTAT=IZ,STATUS='OLD')
  112.       IF(IZ .NE. 0) THEN
  113.           PRINT *,'Open error ',INPUT,IZ
  114.           STOP
  115.       END IF
  116.       OPEN(9,FILE=OUTPUT,IOSTAT=IZ,STATUS='UNKNOWN')
  117.       IF(IZ .NE. 0) THEN
  118.           PRINT *,'Open error ',OUTPUT,IZ
  119.           STOP
  120.       END IF
  121. C
  122. C
  123.       END_SKIPL=TRIMLN(END_SKIP)
  124.       NI=0
  125. 100   CONTINUE
  126.       READ (8,101,END=200) LIGNE
  127.       IF(LIGNE .EQ. ' ') GO TO 100
  128. 101   FORMAT(A)
  129.       IA=INDEX(LIGNE,INDEXENTRY)
  130.       IF(IA .EQ. 0) THEN
  131.           PRINT *,'No \indexentry{ in input line:',LIGNE(:TRIMLN(LIGNE))
  132.           PRINT *,'... ignored'
  133.           GO TO 100
  134.       END IF
  135. C pointer sur le debut du texte
  136.       IA=IA+INDEX(LIGNE(IA:),'{')
  137. C
  138. C ELIMINATION DES ACCENTS
  139. C
  140.       TEXTI=LIGNE
  141.       CALL SUBSTI(TEXTI,'{ ','{',255) 
  142.       CALL SUBSTI(TEXTI,'{} ',' ',255) 
  143.       CALL SUBSTI(TEXTI,'\protect \','\',255)
  144.       CALL SUBSTI(TEXTI,'\protect\','\',255)
  145.       CALL SUBSTI(TEXTI,'\OE ','OE',10)
  146.       CALL SUBSTI(TEXTI,'\AE ','AE',10)
  147.       CALL SUBSTI(TEXTI,'\i }','I}',10)
  148.       CALL SUBSTI(TEXTI,'\oe ','OE',10)
  149.       CALL SUBSTI(TEXTI,'\ae ','AE',10)
  150.       CALL SUBSTI(TEXTI,'\ss ','SS',10)
  151.       CALL SUBSTI(TEXTI,'^^ff','SS',10)
  152.       CALL SUBSTI(TEXTI,'^^df','SS',10)
  153.       CALL SUBSTI(TEXTI,'^^^','OE',10)
  154.       CALL SUBSTI(TEXTI,'^^]','AE',10)
  155.       CALL SUBSTI(TEXTI,'\i ','I',10)
  156.       CALL SUBSTI(TEXTI,'^^P','I',10)
  157.       CALL SUBSTI(TEXTI,'^^[','OE',10)
  158.       CALL SUBSTI(TEXTI,'^^Z','AE',10)
  159.       CALL SUBSTI(TEXTI,'^^Y','SS',10)
  160.       CALL SUBSTI(TEXTI,'^^_','O',10)
  161.       CALL SUBSTI(TEXTI,'^^\','O',10)
  162. C lettres accentuees PC
  163.       CALL SUBSTI(TEXTI,'à','A',255)
  164.       CALL SUBSTI(TEXTI,'ä','A',255)
  165.       CALL SUBSTI(TEXTI,'â','A',255)
  166.       CALL SUBSTI(TEXTI,'╖','A',255)
  167.       CALL SUBSTI(TEXTI,'╢','A',255)
  168.       CALL SUBSTI(TEXTI,'Ä','A',255)
  169.       CALL SUBSTI(TEXTI,'é','E',255)
  170.       CALL SUBSTI(TEXTI,'è','E',255)
  171.       CALL SUBSTI(TEXTI,'ê','E',255)
  172.       CALL SUBSTI(TEXTI,'ë','E',255)
  173.       CALL SUBSTI(TEXTI,'É','E',255)
  174.       CALL SUBSTI(TEXTI,'╘','E',255)
  175.       CALL SUBSTI(TEXTI,'╥','E',255)
  176.       CALL SUBSTI(TEXTI,'╙','E',255)
  177.       CALL SUBSTI(TEXTI,'╪','I',255)
  178.       CALL SUBSTI(TEXTI,'ï','I',255)
  179.       CALL SUBSTI(TEXTI,'╫','I',255)
  180.       CALL SUBSTI(TEXTI,'î','I',255)
  181.       CALL SUBSTI(TEXTI,'ö','O',255)
  182.       CALL SUBSTI(TEXTI,'Ö','O',255)
  183.       CALL SUBSTI(TEXTI,'ô','O',255)
  184.       CALL SUBSTI(TEXTI,'Γ','O',255)
  185.       CALL SUBSTI(TEXTI,'ü','U',255)
  186.       CALL SUBSTI(TEXTI,'Ü','U',255)
  187.       CALL SUBSTI(TEXTI,'û','U',255)
  188.       CALL SUBSTI(TEXTI,'ù','U',255)
  189.       CALL SUBSTI(TEXTI,'Ω','U',255)
  190.       CALL SUBSTI(TEXTI,'ÿ','Y',255)
  191.       CALL SUBSTI(TEXTI,'Θ','U',255)
  192.       CALL SUBSTI(TEXTI,'ç','C',255)
  193.       CALL SUBSTI(TEXTI,'Ç','C',255)
  194. C lettres accentuees codage ASCII
  195.       CALL SUBSTI(TEXTI,'\`a','A',255)
  196.       CALL SUBSTI(TEXTI,'\"a','A',255)
  197.       CALL SUBSTI(TEXTI,'\^a','A',255)
  198.       CALL SUBSTI(TEXTI,'\`A','A',255)
  199.       CALL SUBSTI(TEXTI,'\"A','A',255)
  200.       CALL SUBSTI(TEXTI,'\^A','A',255)
  201.       CALL SUBSTI(TEXTI,'\''e','E',255)
  202.       CALL SUBSTI(TEXTI,'\`e','E',255)
  203.       CALL SUBSTI(TEXTI,'\^e','E',255)
  204.       CALL SUBSTI(TEXTI,'\"e','E',255)
  205.       CALL SUBSTI(TEXTI,'\''E','E',255)
  206.       CALL SUBSTI(TEXTI,'\`E','E',255)
  207.       CALL SUBSTI(TEXTI,'\^E','E',255)
  208.       CALL SUBSTI(TEXTI,'\"E','E',255)
  209.       CALL SUBSTI(TEXTI,'\^i','I',255)
  210.       CALL SUBSTI(TEXTI,'\^I','I',255)
  211.       CALL SUBSTI(TEXTI,'\"i','I',255)
  212.       CALL SUBSTI(TEXTI,'\"I','I',255)
  213.       CALL SUBSTI(TEXTI,'\"o','O',255)
  214.       CALL SUBSTI(TEXTI,'\"O','O',255)
  215.       CALL SUBSTI(TEXTI,'\^o','O',255)
  216.       CALL SUBSTI(TEXTI,'\^O','O',255)
  217.       CALL SUBSTI(TEXTI,'\"u','U',255)
  218.       CALL SUBSTI(TEXTI,'\"U','U',255)
  219.       CALL SUBSTI(TEXTI,'\^u','U',255)
  220.       CALL SUBSTI(TEXTI,'\^U','U',255)
  221.       CALL SUBSTI(TEXTI,'\`u','U',255)
  222.       CALL SUBSTI(TEXTI,'\`U','U',255)
  223.       CALL SUBSTI(TEXTI,'\"y','Y',255)
  224.       CALL SUBSTI(TEXTI,'\"Y','Y',255)
  225. C lettres accentuees au standard de Cork
  226.       CALL SUBSTI(TEXTI,'^^c0','A',255)
  227.       CALL SUBSTI(TEXTI,'^^c1','A',255)
  228.       CALL SUBSTI(TEXTI,'^^c2','A',255)
  229.       CALL SUBSTI(TEXTI,'^^c3','A',255)
  230.       CALL SUBSTI(TEXTI,'^^c4','A',255)
  231.       CALL SUBSTI(TEXTI,'^^c5','A',255)
  232.       CALL SUBSTI(TEXTI,'^^c6','AE',255)
  233.       CALL SUBSTI(TEXTI,'^^c7','C',255)
  234.       CALL SUBSTI(TEXTI,'^^c8','E',255)
  235.       CALL SUBSTI(TEXTI,'^^c9','E',255)
  236.       CALL SUBSTI(TEXTI,'^^ca','E',255)
  237.       CALL SUBSTI(TEXTI,'^^cb','E',255)
  238.       CALL SUBSTI(TEXTI,'^^cc','I',255)
  239.       CALL SUBSTI(TEXTI,'^^cd','I',255)
  240.       CALL SUBSTI(TEXTI,'^^ce','I',255)
  241.       CALL SUBSTI(TEXTI,'^^cf','I',255)
  242.       IF(LANGUAGE .EQ. 3) THEN
  243.         CALL SUBSTI(TEXTI,'^^d1','N[',255)
  244.       ELSE
  245.         CALL SUBSTI(TEXTI,'^^d1','N',255)
  246.       END IF
  247.       CALL SUBSTI(TEXTI,'^^d2','O',255)
  248.       CALL SUBSTI(TEXTI,'^^d3','O',255)
  249.       CALL SUBSTI(TEXTI,'^^d4','O',255)
  250.       CALL SUBSTI(TEXTI,'^^d5','O',255)
  251.       CALL SUBSTI(TEXTI,'^^d6','O',255)
  252.       CALL SUBSTI(TEXTI,'^^d7','OE',255)
  253.       CALL SUBSTI(TEXTI,'^^d8','O',255)
  254.       CALL SUBSTI(TEXTI,'^^d9','U',255)
  255.       CALL SUBSTI(TEXTI,'^^da','U',255)
  256.       CALL SUBSTI(TEXTI,'^^db','U',255)
  257.       CALL SUBSTI(TEXTI,'^^dc','U',255)
  258.       CALL SUBSTI(TEXTI,'^^dd','Y',255)
  259.       CALL SUBSTI(TEXTI,'^^df','SS',255)
  260.       CALL SUBSTI(TEXTI,'^^e0','A',255)
  261.       CALL SUBSTI(TEXTI,'^^e2','A',255)
  262.       CALL SUBSTI(TEXTI,'^^e3','A',255)
  263.       CALL SUBSTI(TEXTI,'^^e4','A',255)
  264.       CALL SUBSTI(TEXTI,'^^e5','A',255)
  265.       CALL SUBSTI(TEXTI,'^^6e','AE',255)
  266.       CALL SUBSTI(TEXTI,'^^e7','C',255)
  267.       CALL SUBSTI(TEXTI,'^^e8','E',255)
  268.       CALL SUBSTI(TEXTI,'^^e9','E',255)
  269.       CALL SUBSTI(TEXTI,'^^ea','E',255)
  270.       CALL SUBSTI(TEXTI,'^^eb','E',255)
  271.       CALL SUBSTI(TEXTI,'^^ec','I',255)
  272.       CALL SUBSTI(TEXTI,'^^ed','I',255)
  273.       CALL SUBSTI(TEXTI,'^^ee','I',255)
  274.       CALL SUBSTI(TEXTI,'^^ef','I',255)
  275.       IF(LANGUAGE .EQ. 3) THEN
  276.         CALL SUBSTI(TEXTI,'^^f1','N[',255)
  277.       ELSE
  278.         CALL SUBSTI(TEXTI,'^^f1','N',255)
  279.       END IF
  280.       CALL SUBSTI(TEXTI,'^^f2','O',255)
  281.       CALL SUBSTI(TEXTI,'^^f3','O',255)
  282.       CALL SUBSTI(TEXTI,'^^f4','O',255)
  283.       CALL SUBSTI(TEXTI,'^^f5','O',255)
  284.       CALL SUBSTI(TEXTI,'^^f6','O',255)
  285.       CALL SUBSTI(TEXTI,'^^f7','OE',255)
  286.       CALL SUBSTI(TEXTI,'^^f9','U',255)
  287.       CALL SUBSTI(TEXTI,'^^fa','U',255)
  288.       CALL SUBSTI(TEXTI,'^^fb','U',255)
  289.       CALL SUBSTI(TEXTI,'^^fc','U',255)
  290.       CALL SUBSTI(TEXTI,'^^fd','Y',255)
  291. C version EURO TEX
  292. C lettres accentuees au standard de Cork
  293.       CALL SUBSTI(TEXTI,'\char "C0{}','A',255)
  294.       CALL SUBSTI(TEXTI,'\char "C1{}','A',255)
  295.       CALL SUBSTI(TEXTI,'\char "C2{}','A',255)
  296.       CALL SUBSTI(TEXTI,'\char "C3{}','A',255)
  297.       CALL SUBSTI(TEXTI,'\char "C4{}','A',255)
  298.       CALL SUBSTI(TEXTI,'\char "C5{}','A',255)
  299.       CALL SUBSTI(TEXTI,'\char "C6{}','AE',255)
  300.       CALL SUBSTI(TEXTI,'\char "C7{}','C',255)
  301.       CALL SUBSTI(TEXTI,'\char "C8{}','E',255)
  302.       CALL SUBSTI(TEXTI,'\char "C9{}','E',255)
  303.       CALL SUBSTI(TEXTI,'\char "CA{}','E',255)
  304.       CALL SUBSTI(TEXTI,'\char "CB{}','E',255)
  305.       CALL SUBSTI(TEXTI,'\char "CC{}','I',255)
  306.       CALL SUBSTI(TEXTI,'\char "CD{}','I',255)
  307.       CALL SUBSTI(TEXTI,'\char "CE{}','I',255)
  308.       CALL SUBSTI(TEXTI,'\char "CF{}','I',255)
  309.       IF(LANGUAGE .EQ. 3) THEN
  310.         CALL SUBSTI(TEXTI,'\char "D1{}','N[',255)
  311.       ELSE
  312.         CALL SUBSTI(TEXTI,'\char "D1{}','N',255)
  313.       END IF
  314.       CALL SUBSTI(TEXTI,'\char "D2{}','O',255)
  315.       CALL SUBSTI(TEXTI,'\char "D3{}','O',255)
  316.       CALL SUBSTI(TEXTI,'\char "D4{}','O',255)
  317.       CALL SUBSTI(TEXTI,'\char "D5{}','O',255)
  318.       CALL SUBSTI(TEXTI,'\char "D6{}','O',255)
  319.       CALL SUBSTI(TEXTI,'\char "D7{}','OE',255)
  320.       CALL SUBSTI(TEXTI,'\char "D8{}','O',255)
  321.       CALL SUBSTI(TEXTI,'\char "D9{}','U',255)
  322.       CALL SUBSTI(TEXTI,'\char "DA{}','U',255)
  323.       CALL SUBSTI(TEXTI,'\char "DB{}','U',255)
  324.       CALL SUBSTI(TEXTI,'\char "DC{}','U',255)
  325.       CALL SUBSTI(TEXTI,'\char "DD{}','Y',255)
  326.       CALL SUBSTI(TEXTI,'\char "DF{}','SS',255)
  327.       CALL SUBSTI(TEXTI,'\char "E0{}','A',255)
  328.       CALL SUBSTI(TEXTI,'\char "E2{}','A',255)
  329.       CALL SUBSTI(TEXTI,'\char "E3{}','A',255)
  330.       CALL SUBSTI(TEXTI,'\char "E4{}','A',255)
  331.       CALL SUBSTI(TEXTI,'\char "E5{}','A',255)
  332.       CALL SUBSTI(TEXTI,'\char "6E{}','AE',255)
  333.       CALL SUBSTI(TEXTI,'\char "E7{}','C',255)
  334.       CALL SUBSTI(TEXTI,'\char "E8{}','E',255)
  335.       CALL SUBSTI(TEXTI,'\char "E9{}','E',255)
  336.       CALL SUBSTI(TEXTI,'\char "EA{}','E',255)
  337.       CALL SUBSTI(TEXTI,'\char "EB{}','E',255)
  338.       CALL SUBSTI(TEXTI,'\char "EC{}','I',255)
  339.       CALL SUBSTI(TEXTI,'\char "ED{}','I',255)
  340.       CALL SUBSTI(TEXTI,'\char "EE{}','I',255)
  341.       CALL SUBSTI(TEXTI,'\char "EF{}','I',255)
  342.       IF(LANGUAGE .EQ. 3) THEN
  343.         CALL SUBSTI(TEXTI,'\char "F1{}','N[',255)
  344.       ELSE
  345.         CALL SUBSTI(TEXTI,'\char "F1{}','N',255)
  346.       END IF
  347.       CALL SUBSTI(TEXTI,'\char "F2{}','O',255)
  348.       CALL SUBSTI(TEXTI,'\char "F3{}','O',255)
  349.       CALL SUBSTI(TEXTI,'\char "F4{}','O',255)
  350.       CALL SUBSTI(TEXTI,'\char "F5{}','O',255)
  351.       CALL SUBSTI(TEXTI,'\char "F6{}','O',255)
  352.       CALL SUBSTI(TEXTI,'\char "F7{}','OE',255)
  353.       CALL SUBSTI(TEXTI,'\char "F9{}','U',255)
  354.       CALL SUBSTI(TEXTI,'\char "FA{}','U',255)
  355.       CALL SUBSTI(TEXTI,'\char "FB{}','U',255)
  356.       CALL SUBSTI(TEXTI,'\char "FC{}','U',255)
  357.       CALL SUBSTI(TEXTI,'\char "FD{}','Y',255)
  358. C
  359. C alphabet espagnol
  360.       IF(LANGUAGE .EQ. 3) THEN
  361.         CALL SUBSTI(TEXTI,'ll','l[',10)
  362.         CALL SUBSTI(TEXTI,'Ll','L[',10)
  363.         CALL SUBSTI(TEXTI,'CH','C[',10)
  364.         CALL SUBSTI(TEXTI,'Ch','C[',10)
  365.         CALL SUBSTI(TEXTI,'ch','c[',10)
  366.       END IF
  367.       CALL SUBSTI(TEXTI,' \penalty \@M \ ',' ',4)
  368.       CALL SUBSTI(TEXTI,'\penalty \@M \ ',' ',4)
  369.       CALL SUBSTI(TEXTI,'\hbox to\z@ {\char 24\hss }c','c',8)
  370.       CALL SUBSTI(TEXTI,
  371.      $   '\hbox to\z@ {\kern 0.1em\char 24\hss }C','C',8)
  372. 105   CONTINUE
  373.       IACC=INDEX(TEXTI,'{\accent ')
  374.       IF(IACC .GT. 0) THEN
  375.         IBCC=INDEX(TEXTI(IACC+1:),'}')+IACC
  376.         IF(TEXTI(IBCC:IBCC) .NE. '}') THEN
  377.           PRINT *,'Clobbered IBCC:',TEXTI(IBCC:IBCC)
  378.           STOP
  379.         END IF
  380.         TEXTJ=TEXTI(IBCC+1:)
  381.         TEXTI(IACC:IACC)=TEXTI(IBCC-1:IBCC-1)
  382.         TEXTI(IACC+1:)=TEXTJ
  383.         PRINT *,TEXTI(:TRIMLN(TEXTI))
  384.         GO TO 105
  385.       END IF
  386.       ICED=INDEX(TEXTI,'\setbox \z@ \hbox')
  387.       IF(ICED .NE. 0) THEN
  388.         IA24=INDEX(TEXTI,'accent 24 ')
  389.         IF(IA24 .NE. 0) THEN
  390.           TEXTJ=TEXTI(IA24+10:)
  391.           TEXTI(ICED:)=TEXTJ
  392.           PRINT *,TEXTI(:TRIMLN(TEXTI))
  393.           GO TO 105
  394.         END IF
  395.       END IF
  396. C
  397. C recherche des deux chaines
  398. C
  399.       IB=0
  400.       IACCOL=1
  401.       DO 80 K=IA,LEN(TEXTI)
  402.       IF(TEXTI(K-1:K-1) .NE. '\') THEN
  403.         IF(TEXTI(K:K) .EQ. '{') THEN
  404.           IACCOL=IACCOL+1
  405.         ELSE IF(TEXTI(K:K) .EQ. '}') THEN
  406.           IACCOL=IACCOL-1
  407.           IF(IACCOL .EQ. 0) THEN
  408.             IB=K
  409.             GO TO 81
  410.           END IF
  411.         END IF
  412.       END IF
  413. 80    CONTINUE
  414. 81    CONTINUE
  415.       IF(IB .LE. IA) THEN
  416.         PRINT *,'Empty item or unbalanced braces:',
  417.      $       TEXTI(:TRIMLN(TEXTI))
  418.         GO TO 100
  419.       END IF
  420. C
  421.       IF(TEXTI(IB+1:IB+1) .NE. '{') THEN
  422.         PRINT *,'Missing second argument oe \indexentry:',
  423.      $       TEXTI(:TRIMLN(TEXTI))
  424.         GO TO 100
  425.       END IF
  426.       IC=INDEX(TEXTI(IB+1:),'}')
  427.       IF(IC .LE. 0) THEN
  428.         PRINT *,'Unbalanced braces:',
  429.      $       TEXTI(:TRIMLN(TEXTI))
  430.         GO TO 100
  431.       END IF
  432.       IC=IC+IB
  433.       IF(TEXTI(IC:IC) .NE. '}') THEN
  434.         PRINT *,'Clobbered IC ',TEXTI(IC:IC)
  435.         STOP
  436.       END IF
  437.       IF(IC-IB .LE. 2) THEN
  438.         PRINT *,'Empty second arg:',
  439.      $       TEXTI(:TRIMLN(TEXTI))
  440.         GO TO 100
  441.       END IF
  442. C
  443. C convertir la zone de comparaison en majuscules
  444. C
  445.       IF(UPCASE_COMP) THEN
  446.         DO 140 IT=IA,IB-1
  447.         TEXTI(IT:IT)=MAJUSC(ICHAR(TEXTI(IT:IT)))
  448. 140     CONTINUE
  449.       END IF
  450. C
  451. C trouve la limite de la chaine de comparaison
  452. C
  453.       DO 120 K=1,NI
  454.       IF(TEXTI(IA:IB-1) .EQ. FTABL(K)) THEN
  455. C recherche de la fin du premier argument dans TABLE
  456.         CLIGNE=TABLE(K) 
  457.         JB=0
  458.         IACCOL=0
  459.         DO 85 KK=1,LEN(CLIGNE)
  460.           IF(CLIGNE(KK-1:KK-1) .NE. '\') THEN
  461.             IF(CLIGNE(KK:KK) .EQ. '{') THEN
  462.               IACCOL=IACCOL+1
  463.             ELSE IF(CLIGNE(KK:KK) .EQ. '}') THEN
  464.               IACCOL=IACCOL-1
  465.               IF(IACCOL .EQ. 0) THEN
  466.                 JB=KK
  467.                 GO TO 86
  468.               END IF
  469.             END IF
  470.           END IF
  471. 85      CONTINUE
  472. 86      CONTINUE
  473. C       PRINT *,'''',TEXTI(IB+1:IC),''''
  474.         IF(JB .EQ. 0) PRINT *,JB,CLIGNE(JB:),'#'
  475.         IF(INDEX(CLIGNE(JB:),TEXTI(IB+1:IC)) .NE. 0) THEN
  476.           PRINT *,'Duplicate reference: ',LIGNE(:TRIMLN(LIGNE))
  477.           GO TO 100
  478.         END IF
  479.         ZQ=TRIMLN(TABLE(K))
  480.         TABLE(K)(ZQ+1:)=','//TEXTI(IB+1:IC)
  481.         GO TO 100
  482.       END IF
  483. 120   CONTINUE
  484.       IF(NI .GE. MTAB) THEN
  485.           PRINT *,'Table overflow, max:',MTAB
  486.           GO TO 200
  487.       END IF
  488.       NI=NI+1
  489.       ORDNO(NI)=NI
  490.       ZZFC=INDEX(LIGNE,'{')
  491.       TABLE(NI)=LIGNE(ZZFC:)
  492.       FTABL(NI)=TEXTI(IA:IB-1)
  493.       GO TO 100
  494. C
  495. 200   CONTINUE
  496.       CLOSE(8)
  497.       PRINT *,'Now sorting'
  498. C
  499. C CLASSEMENT
  500. C
  501. C transformation en majuscules pour classement
  502. C
  503.       DO 185 I=1,NI
  504.       TEXTI=FTABL(I)
  505.         DO 186 IT=1,TRIMLN(TEXTI)
  506.         TEXTI(IT:IT)=MAJUSC(ICHAR(TEXTI(IT:IT)))
  507. 186     CONTINUE
  508.       FTABL(I)=TEXTI
  509. 185   CONTINUE
  510. C
  511.       ISTEP=NI/3+1
  512.       DO 201 ZZ=1,NI*2
  513.       DESORD=0
  514.       ISTEP=ISTEP/3+1
  515.       DO 210 I=1,NI-ISTEP
  516.       II=ORDNO(I)
  517.       JJ=ORDNO(I+ISTEP)
  518.       TEXTI=FTABL(II)
  519.       TEXTJ=FTABL(JJ)
  520.       IF(LLT(TEXTJ,TEXTI)) THEN
  521.         DESORD=1
  522.         ORDNO(I)=JJ
  523.         ORDNO(I+ISTEP)=II
  524.       END IF
  525. 210   CONTINUE
  526.       IF(DESORD .EQ. 0 .AND.  ISTEP .EQ. 1) GO TO 202
  527. 201   CONTINUE
  528.       PRINT *,'failing sort',CHAR(6)
  529. 202   CONTINUE
  530.       DO 300 I=1,NI
  531.       CLIGNE='\indexentry'//TABLE(ORDNO(I))
  532.       IF(END_SKIPL .NE. 0) THEN
  533.         IDEB=INDEX(CLIGNE,END_SKIP(1:END_SKIPL))
  534.         IF(IDEB .NE. 0) THEN
  535.           TEXTI=CLIGNE(IDEB+END_SKIPL:)
  536.           CLIGNE=INDEXENTRY//'{'//TEXTI
  537.           CALL SUBSTI(CLIGNE,'{ ',' ',15)
  538.         END IF
  539.       END IF
  540.       CALL SUBSTI(CLIGNE,'},{',', ',255)
  541.       IF(REPACK) THEN
  542.         CALL SUBSTI(CLIGNE,'{\accent 94 ^^P}','^^ce',255)
  543.         CALL SUBSTI(CLIGNE,'\hbox to\z@ {\char 24\hss }','\c ',255)
  544.         CALL SUBSTI(CLIGNE,'{\accent 18 ','\`{',255)
  545.         CALL SUBSTI(CLIGNE,'{\accent 19 ','\''{',255)
  546.         CALL SUBSTI(CLIGNE,'{\accent 94 ','\^{',255)
  547.         CALL SUBSTI(CLIGNE,'{\accent 127 ','\"{',255)
  548.       END IF
  549. C
  550.       WRITE(9,101) CLIGNE(:TRIMLN(CLIGNE))
  551.       PRINT 102,FTABL(ORDNO(I))(:TRIMLN(FTABL(ORDNO(I))))
  552. 102   FORMAT(1X,A)
  553. 300   CONTINUE
  554.       CLOSE(9)
  555.       STOP
  556.       END
  557.       INTEGER FUNCTION TRIMLN(A)
  558.       IMPLICIT INTEGER(A-Z)
  559.       CHARACTER*(*) A
  560. C
  561.       TRIMLN=LEN(A)
  562. 100   CONTINUE
  563.       IF(TRIMLN .LE. 0) RETURN
  564.       IF(A(TRIMLN:TRIMLN) .EQ. ' ') THEN
  565.         TRIMLN=TRIMLN-1
  566.         GO TO 100
  567.       END IF
  568.       RETURN
  569.       END
  570.       SUBROUTINE FLDEXT(CMDSTR,EXT)
  571.       IMPLICIT INTEGER(A-Z)
  572.       CHARACTER*(*) CMDSTR,EXT
  573. C
  574.       IV=MINDEX(CMDSTR,',')
  575.       IF(IV .GT. 1) THEN
  576.         EXT=CMDSTR(:IV-1)
  577.       ELSE
  578.         EXT=' '
  579.       END IF
  580.       CMDSTR(:IV)=' '
  581.       DO 20 Z=1,LEN(CMDSTR)-IV
  582.       CMDSTR(Z:Z)=CMDSTR(Z+IV:Z+IV)
  583. 20    CONTINUE
  584.       Z=LEN(CMDSTR)-IV+1
  585.       CMDSTR(Z:)=' '
  586.       DO 10 I=1,4
  587.       IF(EXT(1:1) .NE. '#') RETURN
  588.       EXT(1:1)=' '
  589.       CALL LJSTRG(EXT)
  590. 10    CONTINUE
  591.       RETURN
  592.       END
  593.       SUBROUTINE LJSTRG(A)
  594.       IMPLICIT INTEGER(A-Z)
  595.       CHARACTER*(*) A
  596.       CHARACTER*1 U
  597.       Z=0
  598.       LTH=LEN(A)
  599.       DO 10 I=1,LTH
  600.       U=A(I:I)
  601.       IF(ICHAR(U) .GT. ICHAR(' ')) THEN
  602.         Z=Z+1
  603.         A(Z:Z)=U
  604.       END IF
  605. 10    CONTINUE
  606.       IF(Z .LT. LTH) A(Z+1:)=' '
  607.       RETURN
  608.       END
  609.       SUBROUTINE SUBSTI(SOURCE,STRA,STRB,NUM) 
  610.       IMPLICIT INTEGER(A-Z)
  611.       CHARACTER*(*) SOURCE,STRA,STRB
  612. C
  613.       CHARACTER*255 GAUCHE,DROITE 
  614. C
  615.       IF(NUM .GE. 0) THEN 
  616.         ZA=LEN(STRA) 
  617.         ZB=LEN(STRB) 
  618.       ELSE 
  619.         ZA=TRIMLN(STRA) 
  620.         ZB=TRIMLN(STRB) 
  621.       END IF
  622.       GAUCHE=SOURCE
  623.       DO 60 Y=1,ABS(NUM)
  624.       Z=INDEX(GAUCHE,STRA)
  625.       IF(Z .EQ. 0) GO TO 70
  626.       DROITE=GAUCHE(Z+ZA:)
  627.       GAUCHE(Z:)=STRB
  628.       GAUCHE(Z+ZB:)=DROITE
  629. 60    CONTINUE
  630. 70    CONTINUE
  631.       SOURCE=GAUCHE
  632.       RETURN
  633.       END
  634.       FUNCTION MINDEX(A,B)
  635.       IMPLICIT INTEGER(A-Z)
  636.       CHARACTER*(*) A,B
  637.       MINDEX=INDEX(A,B)
  638.       IF(MINDEX .EQ. 0) MINDEX=1+TRIMLN(A)
  639.       RETURN
  640.       END
  641.  
  642.  
  643.